Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/toolkit/riruf1/rufdb.bas

BASIC Source File | 1995-03-23 | 15.7 KB | 617 lines

Option Explicit
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Any) As Long
Global TheDatabase As Database
Global TheDynaset As dynaset
Global TheSnapShot As snapshot
Global nCurrentID%

'RufLogin form variables
Global bLogin%
Global sUserName$, sPassword$

'RufDB Form variables
Global bDBChange%, bRufDbEnd%
Global sDBPath$
Dim sInsert$, sSystem$, sNewStr$
Dim bComma%

Global Const WM_USER = &H400
Global Const CB_FINDSTRING = (WM_USER + 12)
Global Const CB_FINDSTRINGEXACT = (WM_USER + 24)

Function AddQuote (sStr As String) As String
    Dim nOff%, nStart%
    sNewStr = sStr

    nStart = 1
    nOff = InStr(nStart, sNewStr, "`", 1)
    While nOff > 0
        Mid(sNewStr, nOff, 1) = "'"
        nStart = nStart + 1
        nOff = InStr(nStart, sNewStr, "`", 1)
    Wend
    AddQuote = sNewStr
End Function

Function AddQuoteV (vStr As Variant) As String
    Dim nOff%, nStart%
    sNewStr = vStr
    sNewStr = RTrim$(sNewStr)

    nStart = 1
    nOff = InStr(nStart, sNewStr, "`", 1)
    While nOff > 0
        Mid(sNewStr, nOff, 1) = "'"
        nStart = nStart + 1
        nOff = InStr(nStart, sNewStr, "`", 1)
    Wend
    AddQuoteV = sNewStr

End Function

Sub AddToInsert (sValue As String, bLit As Integer)
    If bComma Then
        sInsert = sInsert & ", "
    Else
        bComma = True
    End If

    If bLit Then
        sValue = RemoveQuote(sValue)
        sInsert = sInsert & " '" & RTrim$(sValue) & "'"
    Else
        sInsert = sInsert & RTrim$(sValue)
    End If

End Sub

Sub AddToUpdate (sName As String, sValue As String, bLit As Integer)
    If bComma Then
        sInsert = sInsert & ", "
    Else
        bComma = True
    End If

    If bLit Then
        sValue = RemoveQuote(sValue)
        sInsert = sInsert & sName & " = '" & RTrim$(sValue) & "'"
    Else
        sInsert = sInsert & sName & " = " & RTrim$(sValue)
    End If


End Sub

Sub AddToUpdateV (sName As String, vValue As Variant, bLit As Integer)
    Dim sTmp$
    If bComma Then
        sInsert = sInsert & ", "
    Else
        bComma = True
    End If

    If bLit Then
        sTmp = vValue
        sTmp = RemoveQuote(sTmp)
        sInsert = sInsert & sName & " = '" & RTrim$(sTmp) & "'"
    Else
        sInsert = sInsert & sName & " = " & RTrim$(sTmp)
    End If

End Sub

Sub CheckAndSaveCbo (cboCtrl As ComboBox, sTable$, sField$, bPad%)
    Dim sBuff$, sVal$, nIndex%

    If bPad Then
        sVal = Format$(RTrim$(cboCtrl.Text), "##.00")
        cboCtrl.Text = sVal
    Else
        sVal = RTrim$(cboCtrl.Text)
    End If
    If Len(sVal) > 0 Then
        nIndex = SendMessage(cboCtrl.hWnd, CB_FINDSTRINGEXACT, -1, sVal)

        If nIndex = -1 Then
            cboCtrl.AddItem sVal
            CreateInsert sTable
            AddToInsert sVal, False
            sBuff = GetInsertStatement()
            TheDatabase.Execute sBuff
        End If
    End If

End Sub

Sub CompactDB (sCompDBName As String)
    On Error GoTo errhandler
    Const sTmpDB$ = "rufcomdb.mdb"
    Dim sLocation$, sShortName$
    Dim n%, nErr%
    Dim sMsg$

    n = InStr(1, sDBPath, sCompDBName, 1)
    sLocation = Left$(sDBPath, n - 1)

    n = InStr(1, sCompDBName, ".", 1)
    sShortName = Left(sCompDBName, n - 1)

    sMsg = "Are you sure you want to compact the database?"
    sMsg = sMsg & " All other users should exit the  " & TheAppTitle & " before continuing."
    If Not AskUser(sMsg) Then
        Exit Sub
    End If

    HourglassCursor

    nErr = False
    CompactDatabase sLocation & sCompDBName, sLocation & sTmpDB

    If nErr <> True Then ' if compacting was successful then
        InformUser "Database has been compacted successfully!"

        ' deleting .bak and .ldb files
        Kill sLocation & sShortName & ".bak"
        Kill sLocation & "rufcomdb.ldb"

        ' making a backup of the original and
        ' renaming the compacted to the actual database
        Name sLocation & sCompDBName As sLocation & sShortName & ".bak"
        Name sLocation & sTmpDB As sLocation & sCompDBName
    End If
    ArrowCursor
    Exit Sub

errhandler:
    nErr = True
    If Err <> 53 Then 'skil file not found error
        ArrowCursor
        DatabaseError
    End If
    Resume Next

End Sub

Sub CreateInsert (sTable As String)
    sInsert = "Insert into " & sTable & " values ( "
    bComma = False
End Sub

Sub CreateUpdate (sTable As String)
    sInsert = "Update " & sTable & " Set "
    bComma = False
End Sub

Sub DatabaseError ()
    Dim sMsg$

    Select Case Err

        Case 3000
            sMsg = "Database is exclusively locked."
        Case 3001
            sMsg = "Enter the database path & name."
        Case 3002
            sMsg = "Couldn't start session."
        Case 3003
            sMsg = "Couldn't start transaction; too many transactions already nested."
        Case 3004
            sMsg = "Couldn't find database"
        Case 3005
            sMsg = "Isn't a valid database name."
        Case 3006
            sMsg = "Database is exclusively locked."
        Case 3007
            sMsg = "Couldn't open database."
        Case 3013
            sMsg = "Couldn't rename installable ISAM file."
        Case 3024
            sMsg = "Couldn't find file."
        Case 3025
            sMsg = "Can't open any more files."
        Case 3026
            sMsg = "Not enough space on disk."
        Case 3027
            sMsg = "Couldn't update; database is read-only."
        Case 3028
            sMsg = "Couldn't initialize data access because file 'SYSTEM.MDA' couldn't be opened."
        Case 3029
            sMsg = "Not a valid account name or password."
        Case 3035
            sMsg = "Out of memory."
        Case 3036
            sMsg = "Database has reached maximum size."
        Case 3037
            sMsg = "Can't open any more tables or queries."
        Case 3038
            sMsg = "Out of memory."
        Case 3040
            sMsg = "Disk I/O error during read."
        Case 3041
            sMsg = "Incompatible database version."
        Case 3042
            sMsg = "Out of MS-DOS file handles."
        Case 3043
            sMsg = "Disk or network error."
        Case 3044
            sMsg = "Isn't a valid path."
        Case 3045
            sMsg = "Couldn't use; file already in use."
        Case 3046
            sMsg = "Couldn't save; currently locked by another user."
        Case 3048
            sMsg = "Can't open any more databases."
        Case 3049
            sMsg = "Database is corrupted or isn't a Microsoft Access database."
        Case 3050
            sMsg = "Couldn't lock file; SHARE.EXE hasn't been loaded."
        Case 3051
            sMsg = "Couldn't open file."
        Case 3052
            sMsg = "MS-DOS file sharing lock count exceeded.  You need to increase the number of locks installed with SHARE.EXE."
        Case 3053
            sMsg = "Too many client tasks."
        Case 3055
            sMsg = "Not a valid file name."
        Case 3056
            sMsg = "Couldn't repair this database."
        Case Else
            sMsg = "Database error: " & Err
    End Select

    Beep
    MsgBox sMsg, MB_OK + MB_ICONSTOP, TheAppTitle

End Sub

Sub ExecuteInsert (sBuff As String)
    TheDatabase.Execute (sBuff)
End Sub

Function GetCBOID (cboCtrl As ListBox, sField As String) As Long

    If cboCtrl.ListIndex = -1 Then
        Beep
        MsgBox "No " & sField & " record has been selected!", MB_ICONEXCLAMATION + MB_OK, TheAppTitle
        Exit Function
    End If
    GetCBOID = cboCtrl.ItemData(cboCtrl.ListIndex)

End Function

Function GetCmdLineStr (sStr As String) As String
    Dim nLen%, nPos%, nEnd%
    Dim sCmd$

    sCmd = Command$
    nLen = Len(sStr)
    nPos = InStr(1, sCmd, sStr, 1)
    If nPos Then
        nPos = nPos + nLen
        nEnd = InStr(nPos, sCmd, " ", 1)
        If nEnd Then
            nLen = nEnd - nPos
            GetCmdLineStr = Mid$(sCmd, nPos, nLen)
        Else
            GetCmdLineStr = Mid$(sCmd, nPos)
        End If
    Else
        GetCmdLineStr = ""
    End If

End Function

Sub GetDynaset (sDef As String)
    Dim qDef As querydef

    Set qDef = TheDatabase.OpenQueryDef(sDef)
    Set TheDynaset = qDef.CreateDynaset()
    qDef.Close

End Sub

Function GetID (ByVal sFieldName As String) As Long
    Dim lNewID, lVal As Long
    Dim ssSystem As snapshot
    Dim sBuff$

    sBuff$ = "select " & sFieldName & " From " & sSystem & " Where RecNo = 1;"
    Set ssSystem = TheDatabase.CreateSnapshot(sBuff)

    If Not IsNull(ssSystem(sFieldName)) Then
        lNewID = ssSystem(sFieldName)
    Else
        lNewID = 1
    End If

    lVal = lNewID + 1

    If Not ssSystem.EOF Then

        sBuff$ = "Update " & sSystem & " Set " & sFieldName & " = " & Str$(lVal) & " Where RecNo = 1;"
        TheDatabase.Execute sBuff$
        GetID = lNewID
        Exit Function

    End If

    GetID = -1

End Function

Function GetInsertStatement () As String
    sInsert = sInsert & " )"
    GetInsertStatement = sInsert
End Function

Function GetLBID (lstCtrl As ListBox, sField As String) As Long

    If lstCtrl.ListIndex = -1 Then
        InformUser "No " & sField & " record has been selected!"
        GetLBID = -1
        Exit Function
    End If
    GetLBID = lstCtrl.ItemData(lstCtrl.ListIndex)

End Function

Sub GetSnapshot (sDef As String)
    Dim qDef As querydef

    Set qDef = TheDatabase.OpenQueryDef(sDef)
    Set TheSnapShot = qDef.CreateSnapshot()
    qDef.Close

End Sub

Function GetUpdateStatement (sWhere As String) As String
    sInsert = sInsert & sWhere
    GetUpdateStatement = sInsert
End Function

Function KeyFound (sTable$, sField$, sValue$) As Integer
    Dim sBuff$
    Dim ssData As snapshot

    sBuff = "Select " & sField & " from " & sTable & " where " & sField & " = '" & sValue & "';"
    Set ssData = TheDatabase.CreateSnapshot(sBuff)
    If Not ssData.EOF Then
        KeyFound = True
    Else
        KeyFound = False
    End If
    ssData.Close

End Function

Sub LoadCombo (sQDef As String, lDefault As Long, cboCtrl As ComboBox, bParam As Integer, sSeparator As String, bClear As Integer)
    On Error GoTo loadcomboErr
    Dim dsData As snapshot
    Dim qDef As querydef
    Dim sLine$, i%, nIndex%, sSep$

    HourglassCursor
    nIndex = -1
    Set qDef = TheDatabase.OpenQueryDef(sQDef)
    If bParam Then
        qDef!Param = lDefault
    End If
    Set dsData = qDef.CreateSnapshot()
    qDef.Close

    If Len(sSeparator) = 0 Then
        sSep = " "
    Else
        sSep = sSeparator & " "
    End If

    If bClear Then
        cboCtrl.Clear
    End If

    While Not dsData.EOF
        If Not IsNull(dsData(0)) Then

            sLine = ""
            For i = 1 To dsData.Fields.Count - 1
                If Not IsNull(dsData(i)) Then
                    sLine = sLine & AddQuoteV(dsData(i))
                    If i < dsData.Fields.Count - 1 Then
                        sLine = sLine & sSep
                    End If
                End If
            Next
            cboCtrl.AddItem sLine
            cboCtrl.ItemData(cboCtrl.NewIndex) = dsData(0)
            If lDefault <> -1 Then
                If lDefault = dsData(0) Then
                    nIndex = cboCtrl.NewIndex
                End If
            End If

        End If
        dsData.MoveNext
    Wend
    dsData.Close

    If nIndex <> -1 Then
        cboCtrl.ListIndex = nIndex
    End If
    ArrowCursor
    Exit Sub

loadcomboErr:
    ArrowCursor
    GetErrorMsg Err
    Exit Sub
End Sub

Sub LoadListBox (sQDef As String, lDefault As Long, lstCtrl As ListBox, bParam As Integer, sSeparator As String)
    On Error GoTo loadlistErr
    Dim dsData As snapshot
    Dim qDef As querydef
    Dim sLine$, i%, nIndex%, sSep$, nCnt%

    HourglassCursor
    nIndex = -1
    nCnt = 1
    Set qDef = TheDatabase.OpenQueryDef(sQDef)
    If bParam Then
        qDef!Param = lDefault
    End If
    Set dsData = qDef.CreateSnapshot()
    qDef.Close

    If Len(sSeparator) = 0 Then
        sSep = " "
    Else
        sSep = sSeparator & " "
    End If

    If dsData.Fields.Count = 1 Then
        nCnt = 0
    End If

    lstCtrl.Clear

    While Not dsData.EOF
        If Not IsNull(dsData(0)) Then

            sLine = ""
            For i = nCnt To dsData.Fields.Count - 1
                If Not IsNull(dsData(i)) Then
                    sLine = sLine & AddQuoteV(dsData(i))
                    If i < dsData.Fields.Count - 1 Then
                        sLine = sLine & sSep
                    End If
                End If
            Next
            lstCtrl.AddItem sLine
            If nCnt <> 0 Then
                lstCtrl.ItemData(lstCtrl.NewIndex) = dsData(0)
                If lDefault <> -1 Then
                    If lDefault = dsData(0) Then
                        nIndex = lstCtrl.NewIndex
                    End If
                End If
            End If

        End If
        dsData.MoveNext
    Wend
    dsData.Close

    If nIndex <> -1 Then
        lstCtrl.ListIndex = nIndex
    End If
    ArrowCursor

    Exit Sub
loadlistErr:
    ArrowCursor
    GetErrorMsg Err
    Exit Sub

End Sub

Function PasswordOK () As Integer
    Dim ssData As snapshot
    Dim sBuff$, sTmp

    PasswordOK = False
    sBuff = "Select PersonID, Password from Personnel where UserName = '" & sUserName & "'"
    Set ssData = TheDatabase.CreateSnapshot(sBuff)

    If ssData.EOF Then
        InformUser "Invalid login!"
    Else
        sTmp = ssData("Password")
        sTmp = Encrypt(sTmp)
        If StrComp(sPassword, sTmp) <> 0 Then
            InformUser "Invalid login!"
        Else
            PasswordOK = True
            nCurrentID = ssData("PersonID")
        End If
    End If

End Function

Function RemoveQuote (sStr As String) As String
    Dim nOff%, nStart%

    sNewStr = sStr
    nStart = 1
    nOff = InStr(nStart, sNewStr, "'", 1)
    While nOff > 0
        Mid(sNewStr, nOff, 1) = "`"
        nStart = nStart + 1
        nOff = InStr(nStart, sNewStr, "'", 1)
    Wend

    RemoveQuote = sNewStr
End Function

Sub ScanCombo (ByVal lID As Long, cboCtrl As ComboBox)
    Dim bFound%, i%

    If lID <> -1 Then
        bFound = False
        i = 0
        While Not bFound And i < cboCtrl.ListCount
            If lID = cboCtrl.ItemData(i) Then
                cboCtrl.ListIndex = i
                bFound = True
            End If
            i = i + 1
        Wend
    Else
        cboCtrl.ListIndex = -1
    End If

End Sub

Sub ScanListBox (ByVal lID As Long, lstCtrl As ListBox)
    Dim bFound%, i%

    If lID <> -1 Then
        bFound = False
        i = 0
        While Not bFound And i < lstCtrl.ListCount
            If lID = lstCtrl.ItemData(i) Then
                lstCtrl.ListIndex = i
                bFound = True
            End If
            i = i + 1
        Wend
    Else
        lstCtrl.ListIndex = -1
    End If

End Sub

Sub ScanMultiListBox (ByVal lID As Long, lstCtrl As ListBox)
    Dim bFound%, i%

    If lID <> -1 Then
        bFound = False
        i = 0
        While Not bFound And i < lstCtrl.ListCount
            If lID = lstCtrl.ItemData(i) Then
                lstCtrl.ListIndex = i
                lstCtrl.Selected(i) = True
                bFound = True
            End If
            i = i + 1
        Wend
    Else
        lstCtrl.ListIndex = -1
    End If

End Sub

Sub SetSystemDB (sStr As String)
    sSystem = sStr
End Sub